Pascal Super Library/Pascal Super Library (CW International)(1997).bin/DELPHI32/SEARCH/RUBICON/TAREDIT.PAS

Pascal/Delphi Source File | 1996-10-21 | 8KB | 326 lines

{*********************************************************}
{*             TAREDIT.PAS 1.20             *}
{*      Copyright (c) Tamarack Associates 1996.     *}
{*           All rights reserved.          *}
{*********************************************************}

{$B-}     {* Boolean evaluation *}
{$G+}     {* Generate 286 code  *}
{$X+}     {* eXtended syntax    *}

UNIT taREdit;

INTERFACE

USES
  {$IFDEF WIN32}
  Windows,
  {$ELSE}
  WinTypes,
  {$ENDIF}
  Messages, SysUtils, Classes, Consts, Graphics, Controls, Forms, Dialogs,
  DsgnIntf, TypInfo, StrEdit, StdCtrls, taRubicn, DB, DBTables, Buttons;

TYPE

  TFieldsForm = class(TForm)
    AvailListBox: TListBox;
    SelectListBox: TListBox;
    AddBtn: TButton;
    RemoveBtn: TButton;
    AvailLabel: TLabel;
    SelectLabel: TLabel;
    OkBtn: TBitBtn;
    CancelBtn: TBitBtn;
    procedure CancelBtnClick(Sender: TObject);
    procedure AddBtnClick(Sender: TObject);
    procedure RemoveBtnClick(Sender: TObject);
    procedure AvailListBoxDblClick(Sender: TObject);
    procedure SelectListBoxDblClick(Sender: TObject);
  PRIVATE
    { Private declarations }
    FDictionary : TAbstractDictionary;
    FModified    : BOOLEAN;
    PROCEDURE FieldNamesSetup;
    PROCEDURE SubFieldNamesSetup;
  PUBLIC
    { Public declarations }
  END;

  TEditFunc = FUNCTION(Dictionary : TAbstractDictionary ;
               List : TStrings) : BOOLEAN;

  TFieldNamesProperty = CLASS(TStringListProperty)
   FUNCTION GetAttributes : TPropertyAttributes ; OVERRIDE;
   FUNCTION GetValue : STRING ; OVERRIDE;
   PROCEDURE Edit ; OVERRIDE;
   PROCEDURE EditPrim(EditFunc : TEditFunc);
  END;

  TSubFieldNamesProperty = CLASS(TFieldNamesProperty)
   PROCEDURE Edit ; OVERRIDE;
  END;

  TtaIndexFieldNameProperty = CLASS(TStringProperty)
  PUBLIC
   FUNCTION  GetAttributes : TPropertyAttributes ; OVERRIDE;
   PROCEDURE GetValues(Proc : TGetStrProc) ; OVERRIDE;
  END;

  TtaWildCardProperty = CLASS(TCharProperty)
  PUBLIC
   FUNCTION  GetAttributes : TPropertyAttributes ; OVERRIDE;
   FUNCTION  GetValue : STRING ; OVERRIDE;
   PROCEDURE GetValues(Proc : TGetStrProc) ; OVERRIDE;
   PROCEDURE SetValue(CONST Value : STRING); OVERRIDE;
  END;

  TtaWordDelimsProperty = CLASS(TStringProperty)
  PUBLIC
   FUNCTION  GetValue : STRING ; OVERRIDE;
  END;

IMPLEMENTATION

{$R *.DFM}

FUNCTION EditFieldNames(Dictionary : TAbstractDictionary ;
            List : TStrings) : BOOLEAN ; FAR;
BEGIN
 WITH TFieldsForm.Create(Application) DO
  TRY
   FDictionary := Dictionary;
   FieldNamesSetup;
   ShowModal;
   IF FModified THEN
    BEGIN
     List.Clear;
     List.Assign(SelectListBox.Items);
     IF Dictionary IS TSearchDictionary THEN
      TSearchDictionary(Dictionary).SubFieldNames.Clear
    END;
   Result := FModified;
  FINALLY
   Free
  END
END;

FUNCTION EditSubFieldNames(Dictionary : TAbstractDictionary ;
            List : TStrings) : BOOLEAN ; FAR;
BEGIN
 WITH TFieldsForm.Create(Application) DO
  TRY
   Caption := 'SubFieldNames Property Editor';
   SelectLabel.Caption := 'SubFieldNames';
   FDictionary := Dictionary;
   SubFieldNamesSetup;
   ShowModal;
   IF FModified THEN
    BEGIN
     List.Clear;
     List.Assign(SelectListBox.Items)
    END;
   Result := FModified
  FINALLY
   Free
  END
END;

PROCEDURE   TFieldsForm.FieldNamesSetup;
VAR        i : INTEGER;
BEGIN
 WITH FDictionary, DataSource.DataSet DO
  FOR i := 0 TO FieldCount - 1 DO
   WITH Fields[i] DO
    IF DataType IN FieldTypes THEN
     IF (FieldNames.Count = 0) OR
    (FieldNames.IndexOf(FieldName) = -1) THEN
      AvailListBox.Items.Add(FieldName)
     ELSE
      SelectListBox.Items.Add(FieldName)
END;

PROCEDURE   TFieldsForm.SubFieldNamesSetup;
VAR        i : INTEGER;
BEGIN
 WITH FDictionary AS TSearchDictionary, DataSource.DataSet DO
  FOR i := 0 TO FieldCount - 1 DO
   WITH Fields[i] DO
    IF (DataType IN FieldTypes) AND
       ((FieldNames.Count = 0) OR
    (FieldNames.IndexOf(FieldName) <> -1)) THEN
     IF (SubFieldNames.Count = 0) OR
    (SubFieldNames.IndexOf(FieldName) = -1) THEN
      AvailListBox.Items.Add(FieldName)
     ELSE
      SelectListBox.Items.Add(FieldName)
END;

FUNCTION   TFieldNamesProperty.GetAttributes : TPropertyAttributes;
BEGIN
 Result :=[paDialog]
END;

FUNCTION   TFieldNamesProperty.GetValue : STRING;
BEGIN
 Result := Format('(%s)',[GetPropType^.Name])
END;

PROCEDURE  TFieldNamesProperty.Edit;
VAR       D : TAbstractDictionary;
       B : TBuildDictionary;
BEGIN
 D := TAbstractDictionary(GetComponent(0));
 B := NIL;
 IF D IS TUpdateDictionary THEN B := TUpdateDictionary(D).Builder;
 IF D IS TSearchDictionary THEN B := TSearchDictionary(D).Builder;
 IF B = NIL THEN EditPrim(EditFieldNames)
END;

PROCEDURE  TFieldNamesProperty.EditPrim(EditFunc : TEditFunc);
VAR       D : TAbstractDictionary;
       ErrMsg : STRING[30];
BEGIN
 D := TAbstractDictionary(GetComponent(0));
 ErrMsg := '';
 IF D.DataSource = NIL THEN ErrMsg := 'DataSource is nil'
 ELSE
  IF D.DataSource.DataSet = NIL THEN ErrMsg := 'DataSet is nil'
  ELSE
   IF NOT D.DataSource.DataSet.Active THEN ErrMsg := 'DataSet is Inactive';
 IF ErrMsg ='' THEN
  IF EditFunc(TAbstractDictionary(GetComponent(0)),TStrings(GetOrdValue)) THEN
   Modified
  ELSE
 ELSE
  IF MessageDlg(ErrMsg + '.  Do you wish to use the string list editor?',
        mtConfirmation, mbOkCancel,0) = mrOk THEN
   INHERITED Edit
END;

PROCEDURE  TSubFieldNamesProperty.Edit;
BEGIN
 EditPrim(EditSubFieldNames)
END;

procedure TFieldsForm.CancelBtnClick(Sender: TObject);
begin
 FModified := FALSE
end;

procedure TFieldsForm.AddBtnClick(Sender: TObject);
VAR      i : INTEGER;
begin
 WITH AvailListBox DO
  BEGIN
   i := ItemIndex;
   IF i >= 0 THEN
    BEGIN
     SelectListBox.Items.Add(Items[i]);
     Items.Delete(i);
     FModified := TRUE
    END
  END
end;

procedure TFieldsForm.RemoveBtnClick(Sender: TObject);
VAR      i : INTEGER;
begin
 WITH SelectListBox DO
  BEGIN
   i := ItemIndex;
   IF i >= 0 THEN
    BEGIN
     AvailListBox.Items.Add(Items[i]);
     Items.Delete(i);
     FModified := TRUE
    END
  END
end;

procedure TFieldsForm.AvailListBoxDblClick(Sender: TObject);
begin
 AddBtnClick(NIL)
end;

procedure TFieldsForm.SelectListBoxDblClick(Sender: TObject);
begin
 RemoveBtnClick(NIL)
end;

FUNCTION  TtaIndexFieldNameProperty.GetAttributes : TPropertyAttributes;
BEGIN
 Result := [paValueList] + INHERITED GetAttributes
END;

PROCEDURE TtaIndexFieldNameProperty.GetValues(Proc : TGetStrProc);
VAR      i : INTEGER;
BEGIN
 WITH GetComponent(0) AS TAbstractDictionary DO
  IF (DataSource <> NIL) AND
     (DataSource.DataSet <> NIL) AND
     DataSource.DataSet.Active AND
     (DataSource.DataSet IS TTable) THEN
   WITH TTable(DataSource.DataSet) DO
    FOR i := 0 TO IndexDefs.Count - 1 DO
     WITH IndexDefs[i] DO
      IF StrictChecking THEN
       IF (POS(';',Fields) = 0) AND
      (ixUnique IN Options) AND
      (FindField(Fields) <> NIL) AND
      (FindField(Fields).DataType IN [ftSmallInt,ftWord,ftInteger]) THEN
    Proc(Fields)
       ELSE
      ELSE Proc(Fields)
END;

FUNCTION  TtaWildCardProperty.GetAttributes : TPropertyAttributes;
BEGIN
 Result := [paValueList] + INHERITED GetAttributes
END;

FUNCTION  TtaWildCardProperty.GetValue : STRING;
BEGIN
 Result := INHERITED GetValue;
 IF Result = '#0' THEN
  IF GetName = 'AnyChar' THEN Result := '*'
  ELSE Result := '?'
END;

PROCEDURE TtaWildCardProperty.GetValues(Proc : TGetStrProc);
BEGIN
 Proc('*');
 Proc('?');
 Proc('!');
 Proc('@');
 Proc('#');
 Proc('$');
 Proc('%');
 Proc('&');
 Proc('/');
 Proc('\');
 Proc('+');
 Proc('|');
 Proc('-');
END;

PROCEDURE TtaWildCardProperty.SetValue(CONST Value : STRING);
VAR      SD : TSearchDictionary;
      Ch : CHAR;
BEGIN
 SD := GetComponent(0) AS TSearchDictionary;
 Ch := Value[1];
 IF ((GetName = 'AnyChar') AND (Ch = SD.OneChar)) OR
    ((GetName = 'OneChar') AND (Ch = SD.AnyChar)) THEN
  RAISE EPropertyError.Create(LoadStr(SInvalidPropertyValue))
 ELSE INHERITED SetValue(Value)
END;

FUNCTION  TtaWordDelimsProperty.GetValue : STRING;
BEGIN
 Result := INHERITED GetValue;
 IF Result = '' THEN Result := DefaultWordDelims
END;

END.